home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / akcl1615.lha / lsp / ucall.lisp < prev    next >
Encoding:
Text File  |  1989-05-06  |  4.0 KB  |  144 lines
  1. (in-package 'compiler)
  2. (import 'si::switch)
  3. (import 'sloop::sloop)
  4. (provide "UCALL")
  5.  
  6. ;;ucall is like funcall, except it assumes
  7. ;;1) its first arg has an inline-always property.
  8. ;;2) the order of evaluation of the remaining args is unimportant.
  9.  
  10. ;;This can be useful when we know that the side effects caused by evaluating
  11. ;;the args do not affect the order of evaluation.
  12. ;;It also returns an indeterminate value.
  13.  
  14. (defun c1ucall (args &aux funob (info (compiler::make-info)))
  15.   (setq funob (compiler::c1funob (car args)))
  16.   (compiler::add-info info (cadr funob))
  17.   (list 'ucall info funob (compiler::c1args (cdr args) info))
  18.   )
  19.  
  20. (defun c2ucall (funob args &aux (*inline-blocks* 0)(*vs* *vs*))
  21.   (let* ((fname (caddr funob))
  22.     (props (car (get fname 'inline-always)))
  23.     new-args
  24.     )
  25.     (or props (error "no inline-always prop"))
  26.     (do ((v args (cdr v))
  27.      (types (car props) (cdr types)))
  28.     ((null v) (setq new-args (nreverse new-args)))
  29.     (setq new-args
  30.           (append (inline-args (list (car v)) (list (car types)))
  31.             new-args)))
  32.     (wt-nl)
  33.     (wt-inline-loc (nth 4 props) new-args)
  34.     (wt ";")
  35.     (unwind-exit "Cnil")
  36.     (close-inline-blocks)
  37.     ))
  38.  
  39.  
  40. ;;Usage (comment "hi there") ; will insert a comment at that point in
  41. ;;the program.
  42. (defun c1comment (args)
  43.   (list 'comment (make-info) args))
  44. (defun c2comment (args)
  45.   (let ((string (car args)))
  46.     (if (find #\/ string) (setq string (remove #\/ string)))
  47.     (wt "/* "string " */")))
  48.  
  49. (defmacro comment (a) a nil)
  50.  
  51. ;;Usage: (tlet (char *) jack ....)
  52. ;;--> {char * V1; ...V1..
  53.  
  54. (defun c1tlet (args &aux  (info (make-info)) (*vars* *vars*))
  55.   (let ((sym (cadr args))
  56.     (type (car args))
  57.     form )
  58.     (let ((var (c1make-var sym nil nil nil)))
  59.       (cond ((subtypep type 'fixnum)
  60.          (setf (var-type var) 'fixnum)))
  61.       (push var *vars*)
  62.       (setq form (c1expr* (cons 'progn (cddr args)) info))
  63.       (list 'tlet (second form) type var form))))
  64.  
  65. (defun c2tlet (type var orig &aux (stype type))
  66.   (setf (var-loc var) (next-cvar))
  67.   (or (stringp type) (setq stype (format nil "~(~a~)" type)))
  68.   (setf (var-kind var)
  69.     (cond ((subtypep type 'fixnum)
  70.            (setf (var-type var) 'fixnum))
  71.           (t 'object)))
  72.   (if (listp type) (setq stype (string-trim "()" stype)))
  73.   (wt-nl "{"  stype " V" (var-loc var) ";" )
  74.   (c2expr orig)
  75.   (wt "}"))
  76.  
  77. (si::putprop 'tlet 'c1tlet 'c1special)
  78. (si::putprop 'tlet 'c2tlet 'c2)
  79.  
  80.  
  81. (defun c1clet (args)
  82.   (let ((string (car args))
  83.     (form (c1expr (cons 'progn (cdr args)))))
  84.     (list 'clet (second form) string form)))
  85.  
  86. (defun c2clet (string orig )
  87.   (wt-nl "{" string)
  88.   (c2expr orig)
  89.     (wt "}"))
  90.  
  91. ;;Usage: Takes a STRING and BODY.  Acts like progn
  92. ;;on the body, but the c code will have {string . c code for body}
  93. ;;Sample (clet "int jack; char *jane;" ....)
  94. (defmacro clet (string &rest body) string `(progn ,@ body))
  95.  
  96. (si::putprop 'clet 'c1clet 'c1special)
  97. (si::putprop 'clet 'c2clet 'c2)
  98.  
  99.  
  100. (si::putprop 'comment 'c1comment 'c1special)
  101. (si::putprop 'comment 'c2comment 'c2)
  102.  
  103.  
  104.   
  105.  
  106.  
  107. (si::putprop 'ucall 'c1ucall 'c1)
  108. (si::putprop 'ucall 'c2ucall 'c2)
  109.  
  110.  
  111.  
  112. (defmacro def-inline (name args return-type &rest bod)
  113.   (let* ((side-effect-p (if (member (car bod)
  114.                     '(:side-effect nil t))
  115.                 (prog1  (and (car bod) t) (setq bod (cdr bod)))
  116.               nil))
  117.      (inline (list args return-type side-effect-p nil (car bod))))
  118.     `(car (push ',inline
  119.         (get ',name 'inline-always)))))
  120.  
  121.  
  122.  
  123.  
  124. (defmacro defun-inline (name args return-type &rest bod)
  125.   (let* ((sym (gensym))
  126.      (named-args
  127.       (nthcdr (- 10 (length args)) '(X9 X8 X7 X6 X5 X4 X3 X2 X1 X0)))
  128.      (inline (eval `(def-inline ,sym ,args ,return-type ,@ bod))))
  129.     `(progn
  130.        (defun ,name  ,named-args
  131.      (declare ,@ (sloop for v in named-args for w in args
  132.                 when (not (eq t v))
  133.                 collect (list w v)))
  134.      (the ,return-type (,sym ,@ named-args)))
  135.        (push  ',inline
  136.           (get ',name 'inline-always)))))
  137.  
  138. (defmacro def-ucall (fun args string)
  139.   (let ((sym (gensym)))
  140.     `(progn
  141.     (def-inline ,sym ,args t t ,string)
  142.     (defmacro ,fun (&rest args) `(ucall ',',sym ,@ args)))))
  143.  
  144.